home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / KERNEL4.SEQ < prev    next >
Text File  |  1988-09-23  |  13KB  |  372 lines
  1. \ KERNEL4.SEQ   Last part of the kernel file, finishes up the compile.
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE KERNEL4.SEQ
  8.  
  9. FORTH DEFINITIONS   META IN-META
  10.  
  11. VARIABLE #USER
  12.  
  13. VOCABULARY USER   USER DEFINITIONS
  14.  
  15. : ALLOT         ( n -- ) #USER +!   ;
  16.  
  17. ' CREATE        ( avoid recursion: leave address for ,-X in CREATE )
  18.  
  19. : CREATE        ( -- )
  20.                 [ ,-X ]         \ compile addr of CREATE
  21.                 #USER @ ,
  22.                 ;USES  DOUSER-VARIABLE ,-X
  23.  
  24. : VARIABLE      ( -- ) CREATE   2 ALLOT   ;
  25.  
  26. : DEFER         ( -- ) VARIABLE   ;USES   DOUSER-DEFER  ,-X
  27.  
  28. FORTH DEFINITIONS   META IN-META
  29.  
  30. : >IS           ( cfa -- data-address )
  31.                 DUP 1+ @ OVER >BODY +
  32.                 DUP [  [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP
  33.                 DUP [  [ASSEMBLER] DOUSER-DEFER    META ] LITERAL = SWAP
  34.                 DROP   OR IF   >BODY @ UP @ +   ELSE    >BODY   THEN   ;
  35.  
  36. : (IS)          ( cfa --- ) 2R@ @L >IS !   R> 2+ >R   ;
  37.  
  38. : IS            ( cfa --- ) STATE @
  39.                 IF  COMPILE (IS)  ELSE  ' >IS !  THEN ; IMMEDIATE
  40.  
  41. : SELECT        ( N1 --- )
  42.                 14 bdos drop
  43.                 seqhandle >hndle @ -2 =
  44.                 if      -1 seqhandle >hndle !
  45.                 then    ;
  46.  
  47. : A:            ( --- )         0 SELECT ;
  48. : B:            ( --- )         1 SELECT ;
  49. : C:            ( --- )         2 SELECT ;
  50. : D:            ( --- )         3 SELECT ;
  51.  
  52. : QUIT          ( -- )
  53.                 SP0 @ 'TIB !    [COMPILE] [
  54.                 BEGIN   BEGIN RP0 @ RP! STATUS QUERY  RUN
  55.                               STATE @ NOT UNTIL ."  ok" AGAIN  ;
  56.  
  57. DEFER BOOT
  58. DEFER INITSTUFF   ' SEQINIT IS INITSTUFF
  59. DEFER SEGSET      ' SETYSEG IS SEGSET
  60.  
  61. : WARMSTRT      ( --- )
  62.                 FORTH
  63.                 TRUE ABORT" Warm Start" ;
  64.  
  65. DEFER WARMFUNC  ' WARMSTRT IS WARMFUNC
  66.  
  67. : WARM          ( -- )
  68.                 [ LABEL WARMBODY ]
  69.                 WARMFUNC ;
  70.  
  71. : COLD          ( -- )
  72.                 [ LABEL COLDBODY ]
  73.                 SEGSET VMODE.SET INITSTUFF
  74.                 BOOT QUIT   ;
  75.  
  76. : START         ( -- )
  77.                 SP0 @ 'TIB !
  78.                 >IN OFF
  79.                 SPAN OFF
  80.                 #TIB OFF
  81.                 LOADING OFF
  82.                 DEFAULT INTERPRET ;
  83.  
  84. VARIABLE BIOSBKSAVE     0 ,-T
  85. VARIABLE DIV0SAVE       0 ,-T
  86.  
  87. CODE RESTORE_VECTORS    ( --- )         \ Restores Control BREAK
  88.                 MOV AX, CS              MOV DS, AX
  89.                 MOV DX, CS: BIOSBKSAVE
  90.                 MOV DS, CS: BIOSBKSAVE 2+
  91.                 MOV AX, # $251B
  92.                 INT $21
  93.                 MOV AX, CS              MOV DS, AX
  94.                 MOV DX, CS: DIV0SAVE
  95.                 MOV DS, CS: DIV0SAVE 2+
  96.                 MOV AX, # $2500
  97.                 INT $21
  98.                 MOV AX, CS              MOV DS, AX
  99.                 NEXT                    END-CODE
  100.  
  101. : DIV0STRT      ( --- )
  102.                 TRUE ABORT" Divide OVERFLOW error" ;
  103.  
  104. DEFER DIV0FUNC  ' DIV0STRT IS DIV0FUNC
  105. DEFER BYEFUNC   ' NOOP IS BYEFUNC
  106.  
  107. : BYE           ( -- )
  108.                 RESTORE_VECTORS
  109.                 BYEFUNC
  110.                 CR CR ." Leaving" CR 0 0 BDOS  ;
  111.  
  112. : DIVIDE0       ( STATUS_reg, CS, IP, AX, BX, CX, DX, SI, BP --- )
  113.                 [ LABEL DIV0BODY ]
  114.                 DIV0FUNC BYE ;
  115.  
  116. LABEL DIV0BK    STI             \ Handle a Divide by 0 interupt
  117.                 PUSH AX
  118.                 PUSH BX
  119.                 PUSH CX
  120.                 PUSH DX
  121.                 PUSH SI
  122.                 PUSH DI
  123.                 PUSH BP
  124.                 MOV AX, # DIV0BODY 5 -
  125.                 JMP AX
  126.                 END-CODE
  127.  
  128. LABEL SETBRK    PUSH ES
  129.                 MOV AX, CS
  130.                 MOV DS, AX
  131.                 MOV AX, # $AD26         \ Value to restore in >NEXT
  132.                 MOV >NEXT AX            \ Restore it
  133.                 MOV AX, # $E0FF         \ Value to restore in >NEXT + 2
  134.                 MOV >NEXT 2+ AX         \ Restore it
  135.                 MOV DX, # BIOSBK
  136.                 MOV AX, # $251B         \ BIOS Break
  137.                 INT $21
  138.                 MOV DX, # DOSBK
  139.                 MOV AX, # $2523         \ DOS Break
  140.                 INT $21
  141.                 MOV DX, # 1
  142.                 MOV AX, # $3301         \ Enable DOS Break
  143.                 INT $21
  144.                 MOV DX, # DIV0BK
  145.                 MOV AX, # $2500         \ BIOS Break
  146.                 INT $21
  147.                 POP ES
  148.                 RET             END-CODE
  149.  
  150. LABEL SAVEVECTORS ( --- )       \ Just save Divide by 0 & Cntrl Brk for now
  151.                 PUSH ES
  152.                 MOV AX, # $351B          \ Get the interupt vector for
  153.                 INT $21                  \ BIOS control break vector
  154.                 MOV BIOSBKSAVE BX
  155.                 MOV BIOSBKSAVE 2+ ES    \ Save old vector
  156.                 MOV AX, # $3500          \ Get the interupt vector for
  157.                 INT $21                  \ DIVIDE by 0
  158.                 MOV DIV0SAVE BX
  159.                 MOV DIV0SAVE 2+ ES      \ Save old vector
  160.                 POP ES
  161.                 RET             END-CODE
  162.  
  163. CODE SET_VECTORS ( --- )
  164.                 CALL SETBRK
  165.                 NEXT            END-CODE
  166.  
  167. [FORTH] ASSEMBLER
  168.  
  169. LABEL WORIG
  170. HERE ORIGIN 6 + - ORIGIN 4 + !-T  ( WARM ENTRY )
  171.         MOV AX, # WARMBODY 5 -
  172.         JMP AX
  173.         END-CODE
  174.  
  175. LABEL CORIG
  176. HERE ORIGIN 3 + - ORIGIN 1+ !-T  ( COLD ENTRY )
  177.         MOV AX, CS                      \ move CS to AX
  178.         MOV DS, AX
  179.         MOV SS, AX
  180.         MOV BX, YSTART                  \ Read YSTART
  181.         OR BX, BX 0<>                   \ If not reset, then move stuff
  182.      IF
  183.         ADD AX, ' #CODESEGS >BODY       \ Add CODE segments and LIST
  184.         ADD AX, ' #LISTSEGS >BODY       \ segments to get to head space.
  185.         MOV ES, AX                      \ move head seg to ES
  186.         MOV CX, YDP
  187.         MOV DI, # 0                     \ Clear DI
  188.         MOV SI, YSTART                  \ MOV YSTART to AX
  189.         OR CX, CX 0<>                   \ if YDP was not zero (0)
  190.         IF      CLD
  191.                 REPZ
  192.                 MOVSB                   \ move HEADS to head space
  193.                 CLD
  194.         THEN
  195.         MOV YSEG ES                     \ set YSEG to ES
  196.      THEN
  197.         MOV BX, XMOVED                  \ Has LIST been moved?
  198.         OR BX, BX 0=                    \ If not reset, then move stuff
  199.      IF
  200.         MOV AX, DS                      \ move DS to AX
  201.         ADD AX, ' #CODESEGS >BODY       \ Add 64k to get to heads
  202.         MOV ES, AX                      \ move head seg to ES
  203.         MOV CX, XSEGLEN
  204.         SHL CX, # 1                     \ MULTIPLY BY 16 DECIMAL
  205.         SHL CX, # 1
  206.         SHL CX, # 1
  207.         SHL CX, # 1
  208.         MOV DI, # 0                     \ Clear DI
  209.         MOV SI, DPSTART                 \ MOV source offset to SI
  210.         OR CX, CX 0<>                   \ if DPSTART was not zero (0)
  211.         IF      CLD             \ Forward move, NOT backwards this time.
  212.                 REPZ
  213.                 MOVSB                   \ move LISTS to LIST space
  214.                 CLD
  215.         THEN
  216.         MOV XSEG ES                     \ set XSEG to ES
  217.      THEN
  218.         CALL SAVEVECTORS                \ Save existing vectors
  219.         CALL SETBRK                     \ Install Break vectors
  220.  
  221.         MOV AX, ' #CODESEGS >BODY
  222.         SUB AX, # 1                     \ One less than max
  223.         SHL AX, # 1
  224.         SHL AX, # 1
  225.         SHL AX, # 1
  226.         SHL AX, # 1
  227.  
  228.         MOV ' LIMIT 3 + AX              \ LIMIT
  229.         SUB AX, # 10
  230.         MOV ' FIRST 3 + AX              \ FIRST = LIMIT - 10h
  231.         SUB AX, # 10
  232.         MOV RP, AX                      \ RP = FIRST - 10h
  233.         MOV BX, # RP0
  234.         ADD BX, UP
  235.         MOV 0 [BX], RP                  \ RP0 = RP
  236.         SUB AX, # 200
  237.         MOV 'TIB AX                     \ TIB = RP - 200 DECIMAL
  238.         MOV BX, # SP0
  239.         ADD BX, UP
  240.         MOV 0 [BX], AX                  \ SP0 = TIB
  241.         MOV SP, AX                      \ SP = TIB
  242.         MOV AX, COLDBODY 2-
  243.         ADD AX, XSEG
  244.         MOV ES, AX
  245.         MOV IP, # 0
  246.         NEXT
  247.         END-CODE
  248.   IN-META
  249.  
  250. HERE UP !-T     ( SET UP USER AREA )
  251.        0 ,      ( TOS )
  252.        0 ,      ( ENTRY )
  253.        0 ,      ( LINK )
  254.        0 ,      ( ES0 )
  255. INIT-R0 256 - , ( SP0 )
  256.  INIT-R0 ,      ( RP0 )
  257.        0 ,      ( DP )          ( Must be patched later )
  258.        0 ,      ( OFFSET )
  259.       10 ,      ( BASE )
  260.        0 ,      ( HLD )
  261.    FALSE ,      ( PRINTING )
  262. ' (EMIT) ,      ( EMIT )
  263. ' (KEY?) ,      ( KEY? )
  264. ' (KEY)  ,      ( KEY  )
  265. ' (TYPE) ,      ( TYPE )
  266. ' (EXTYPE) ,    ( EXTYPE )
  267.  
  268. 0 , 0 , 0 , 0 , 0 ,             \ room for 10 additional USER variables
  269. 0 , 0 , 0 , 0 , 0 ,
  270.  
  271. : DEPTH         ( -- n )   SP@ SP0 @ SWAP - 2/   ;
  272.  
  273. VARIABLE MAX.S
  274.  
  275. : .S            ( -- )    DEPTH 0< ABORT" Stack UNDERFLOW !! "
  276.                 DEPTH ?DUP MAX.S @ 1 < IF 4 MAX.S ! THEN
  277.                 IF      DUP ."  [" 1 .R ." ]" 0 SWAP 1- MAX.S @ 1- MIN
  278.                         DO I PICK 7 U.R BL FEMIT -1 +LOOP
  279.                 ELSE    ."  Stack Empty. "  THEN ;
  280.  
  281. : .ID           ( nfa -- )
  282.                 DUP 1+ DUP YC@ ROT YC@ 31 AND 0
  283.                ?DO      DUP 127 AND FEMIT 128 AND
  284.                         IF   ASCII _ 128 OR   ELSE  1+ DUP YC@  THEN
  285.                 LOOP    2DROP BL FEMIT ;
  286.  
  287. : DUMP          ( addr len -- )
  288.               0 DO   CR DUP 6 .R SPACE  16 0 DO   DUP C@ 3 .R 1+   LOOP
  289.             16 +LOOP   DROP   ;
  290.  
  291. : RECURSE       ( -- ) LAST @ NAME> X,  ;  IMMEDIATE
  292.  
  293. : H.            ( N1 --- ) BASE @ >R HEX U. R> BASE ! ;
  294.  
  295. VARIABLE LMARGIN    0 LMARGIN !-T
  296. VARIABLE RMARGIN   70 RMARGIN !-T
  297. VARIABLE TABSIZE    8 TABSIZE !-T
  298.  
  299. : ?LINE         ( n -- )
  300.                 #OUT @ +  RMARGIN @ > IF CR LMARGIN @ SPACES THEN ;
  301.  
  302. : ?CR           ( -- )  0 ?LINE  ;
  303.  
  304. : TAB           ( --- ) #OUT @ TABSIZE @ MOD TABSIZE @ SWAP - SPACES ;
  305.  
  306. : \             ( --- ) SPAN @ >IN ! ; IMMEDIATE
  307.  
  308. ' (.")                            :RESOLVES <(.")>
  309. ' (")                             :RESOLVES <(")>
  310. ' (;CODE)                         :RESOLVES <(;CODE)>
  311. ' (;USES)                         :RESOLVES <(;USES)>
  312. ' (IS)                            :RESOLVES <(IS)>
  313. ' (ABORT")                        :RESOLVES <(ABORT")>
  314.  [ASSEMBLER] >NEXT    META         RESOLVES <VARIABLE>
  315.  [ASSEMBLER] DOUSER-DEFER META     RESOLVES <USER-DEFER>
  316.  [ASSEMBLER] DOUSER-VARIABLE META  RESOLVES <USER-VARIABLE>
  317.  
  318. ' DEFINITIONS :RESOLVES DEFINITIONS
  319. ' [           :RESOLVES [
  320. ' ?MISSING    :RESOLVES ?MISSING
  321. ' QUIT        :RESOLVES QUIT
  322. ' .ID         :RESOLVES .ID
  323.  
  324. \ Fill in some deferred words
  325. ' CRLF          IS CR
  326. ' NOOP          IS WHERE
  327. ' CR            IS STATUS
  328. ' START         IS BOOT
  329. ' (PRINT)       IS PEMIT
  330. ' (CONSOLE)     IS CONSOLE
  331.  
  332. ' FORTH >BODY-T CURRENT !-T
  333. ' FORTH >BODY-T CONTEXT !-T
  334.  
  335. HERE-T  DP UP @-T + !-T               ( INIT USER DP )
  336. #USER-T @ #USER !-T                   ( INIT USER VAR COUNT )
  337. TRUE  CAPS !-T                        ( SET TO IGNORE CASE )
  338. TRUE WARNING !-T                      ( SET TO ISSUE WARNINGS )
  339. 31 WIDTH !-T                          ( 31 CHARACTER NAMES )
  340. VOC-LINK-T @ VOC-LINK !-T             ( INIT VOC-LINK )
  341.  
  342. CR
  343. CR .( Unresolved references: )          CR   .UNRESOLVED ?NEWPAGE
  344. CR .(     Statistics: )
  345. CR .( Last  Host Address:        )      [FORTH] HERE U.
  346. CR .( First Target Code Address: )      META 256 THERE U.
  347. CR .( Last  Target Code Address: )      META HERE-T THERE U.
  348.                                         META 256 THERE          \ start addr
  349.                                         SVXSEG     DPSTART !-T
  350.                                         HERE-X DROP 1+
  351.                                         0 XS: DROP - XSEGLEN !-T
  352. CR .( CODE space used:           )      HERE-T U.
  353. CR .( LIST space used:           )      HERE-X SWAP 0 XS: DROP - 16 * + U.
  354. CR .( HEAD space used:           )      HERE-Y U.
  355.                                         HERE-X DROP 1+ 0 XS: DROP -
  356.                                         DUP 16 * ALLOT-T DROP
  357.                                                         0 XDP ( UP @-T + ) !-T
  358.                                         SVYSEG DUP YSTART !-T
  359.                                         0 XMOVED !-T
  360.                                         HERE-Y +   HERE-Y YDP ( UP @-T + ) !-T
  361.                                         DUP THERE ONLY FORTH ALSO SP@ SWAP -
  362. CR .( Free Symbol Table bytes:   )      U.
  363. ONLY FORTH ALSO
  364.  
  365. .COMPSTAT
  366.  
  367. ( A1 N1 --- )   ZSAVE KERNEL.COM   FORTH
  368.  
  369. CR .( Now type EXTEND <enter> at the DOS prompt.)
  370. CR
  371.  
  372.